home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / pc / SPADV.ZIP / TITLE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1980-01-01  |  4.7 KB  |  189 lines
  1. unit Title;
  2.  
  3. interface
  4.  
  5. uses Graph,Crt,Globals;
  6.  
  7. var
  8.   Octave, Tempo :byte;
  9.   AllLength,Music : real;
  10.   Step : boolean;
  11.  
  12.   procedure ShowTitle;
  13.   procedure InitPlay;
  14.   procedure Play(ComLin : string);
  15.  
  16. implementation
  17.  
  18. procedure InitPlay;
  19. begin
  20.   Octave := 2;
  21.   AllLength := 1/4;
  22.   Tempo := 120;
  23.   Music := 7/8;
  24.   Step := True;
  25. end;
  26.  
  27. procedure Play(ComLin : string);
  28. type
  29.   ChrSet = set of char;
  30. const
  31.   Comms : ChrSet = ['L','M','N','<','>','O','P','S','T'];
  32.   Notes : ChrSet = ['A'..'G'];
  33.   Appix : ChrSet = ['#','+','-','.'];
  34.   Numbers : ChrSet = ['0'..'9'];
  35. var
  36.   Ctr : integer;
  37.   ComLinPos : byte;
  38.   Command : string;
  39.  
  40.   procedure NoSpaces (var Lin : string);
  41.   var Tmp : string;
  42.       Ctr : byte;
  43.   begin
  44.     Tmp := '';
  45.     for Ctr := 1 to Length (Lin) do
  46.       if not (Lin[Ctr] in [' ',',']) then Tmp := Tmp + UpCase(Lin[Ctr]);
  47.     Lin := Tmp;
  48.   end;
  49.   function GetSymbol (Lin : string; LinPos : byte; TrmSet : ChrSet) : string;
  50.   var ComLen : byte;
  51.   begin
  52.     GetSymbol := '';
  53.     if Lin [LinPos] in TrmSet then begin
  54.       ComLen := 1;
  55.       while not (Lin [LinPos+ComLen] in TrmSet) and
  56.             not (LinPos+ComLen>255) do Inc (ComLen);
  57.       GetSymbol := Copy (Lin,LinPos,ComLen);
  58.     end;
  59.   end;
  60.   function GetNumber (Lin : string; var LinPos : byte) : integer;
  61.   var ComLen : byte;
  62.       Code,Tmp : integer;
  63.   begin
  64.     Tmp := 0;
  65.     ComLen := 1;
  66.     while Lin [LinPos+ComLen] in Numbers do
  67.       Inc (ComLen);
  68.     Val (Copy (Lin,LinPos,ComLen),Tmp,Code);
  69.     Inc (LinPos,ComLen-1);
  70.     GetNumber := Tmp;
  71.   end;
  72.  
  73.   procedure ProcessCommand (Com : string);
  74.   var ThisLen : real;
  75.       p : byte;
  76.   begin
  77.     p := 2;
  78.     case Com[1] of
  79.       'L' : AllLength := 1/GetNumber (Com,p);
  80.       '<' : if Octave > 0 then Dec (Octave);
  81.       '>' : if Octave < 9 then Inc (Octave);
  82.       'O' : Octave := GetNumber (Com,p);
  83.       'P' : begin
  84.               NoSound;
  85.               ThisLen := AllLength;
  86.               if Length(Com)>1 then ThisLen := 1/GetNumber (Com,p);
  87.               Delay (Round(ThisLen*(256-Tempo)*15));
  88.             end;
  89.       'T' : Tempo := GetNumber (Com,p);
  90.       'M' : case Com[2] of
  91.               '7' : Music := 7/8;
  92.               '1' : Music := 1;
  93.               '3' : Music := 3/4;
  94.             end;
  95.       'S' : Step := Boolean (Ord(Com[2])-48);
  96.     end;
  97.   end;
  98.   procedure PlayNote (Com : string);
  99.   var Ctr,ThisOct : byte;
  100.       Frequency,ThisLen : real;
  101.       Note,Dummy : integer;
  102.   begin
  103.     ThisOct := Octave;
  104.     ThisLen := AllLength;
  105.     Note := Pos (Com[1], 'C D EF G A B');
  106.     Ctr := 2;
  107.     while Ctr <= Length(Com) do begin
  108.       case Com[Ctr] of
  109.         '#','+' : Inc (Note);
  110.             '-' : Dec (Note);
  111.             '.' : ThisLen := ThisLen * 3/2;
  112.        '0'..'9' : ThisLen := 1/GetNumber (Com,Ctr);
  113.       end;
  114.       Inc (Ctr);
  115.     end;
  116.     if Note<1 then begin
  117.       Dec (ThisOct);
  118.       Note := 12;
  119.     end else
  120.     if Note>12 then begin
  121.       Inc (ThisOct);
  122.       Note := 1;
  123.     end;
  124.     Frequency := 32.625;
  125.     for Ctr := 1 to ThisOct do
  126.       Frequency := Frequency * 2;
  127.     for Ctr := 1 to Note - 1 do
  128.       Frequency := Frequency * 1.059463094;
  129.     if ThisLen <> 0.0 then
  130.     begin
  131.       if Step then NoSound;
  132.       Sound(Round(Frequency));
  133.       Delay(Round(ThisLen*(256-Tempo)*15*Music));
  134.     end
  135.     else Sound(Round(Frequency));
  136.   end;
  137.  
  138. begin
  139.   NoSound;
  140.   NoSpaces (ComLin);
  141.   ComLinPos := 1; Command := '';
  142.   repeat
  143.     Command := GetSymbol (ComLin,ComLinPos,Comms+Notes);
  144.     if KeyPressed and ShwTitle then begin
  145.       K1 := ReadKey; Inc (Page);
  146.       if Page = 2 then Move (Tit2,Scr,16240);
  147.     end;
  148.     if (Command <> '') then begin
  149.       if Command [1] in Comms then ProcessCommand (Command)
  150.         else if Command [1] in Notes then PlayNote (Command);
  151.     end;
  152.     Inc (ComLinPos, Length (Command));
  153.   until (ComLinPos > Length (ComLin)) or ((Page > 2) and ShwTitle);
  154.   NoSound;
  155. end;
  156.  
  157.                                             (***** SHOW TITLE PAGES ****)
  158. procedure ShowTitle;
  159. var PauseTemp : shortint;
  160. begin
  161.   PauseTemp := Pause;
  162.   Pause := 0;
  163.   ShwTitle:=True;
  164.   ClearDevice;
  165.   Delay (400);
  166.   Move (Tit1,Scr,16240); Page := 1;
  167.   Play ('t160 l8');
  168.   if Page<=2 then repeat
  169.     Ctr := 1;
  170.     repeat
  171.       case Ctr of             { Play tune in different octaves }
  172.         1 : Octave := 4;
  173.         2 : Octave := 6;
  174.         3 : Octave := 2;
  175.       end;
  176.       Play ('d4<gab>cd4<gpgp>e4cdef#g4<gpgp'+
  177.            +'>c4dc<bab4>c<bagf#4gabgb4a2>'+
  178.            +'d4<gab>cd4<gpgp>e4cdef#g4<gpgp'+
  179.            +'>c4dc<bab4>c<baga4bagf#g2<g4p4');
  180.       Inc (Ctr);
  181.     until (Ctr>3) or (Page>2);
  182.   until Page >2;
  183.   ShwTitle:=False;
  184.   Pause := PauseTemp;
  185. end;
  186.  
  187. begin
  188.   InitPlay;
  189. end.